home *** CD-ROM | disk | FTP | other *** search
/ The X-Philes (2nd Revision) / The X-Philes Number 1 (1995).iso / xphiles / hp48hor1 / qrad.src < prev    next >
Text File  |  1990-10-18  |  2KB  |  90 lines
  1. %%HP: T(3)A(D)F(.);
  2. by David Lowenstein
  3. DIR
  4.   MN
  5.     \<< \->NUM DUP SIGN SWAP ABS DUP IP 10 OVER DUP
  6.       \<< XPON
  7.       \>> IFT - FIX SWAP FP \->Q STD + *
  8.     \>>
  9.   OQF
  10.     \<< \->NUM DUP SIGN SWAP SQ 5 FIX \->Q DUP TYPE
  11.       \<< OBJ\-> DROP2 PF FS SWAP PF FS
  12.       \>>
  13.       \<< { 1 1 } SWAP PF FS
  14.       \>> IFTE 1 1 \-> B A D E
  15.       \<< 1 A SIZE 1 -
  16.         FOR c A c 1 + GET A c GET 2 / DUP FP
  17.           \<< IP OVER SWAP ^ 'D' STO* 'E' STO*
  18.           \>>
  19.           \<< ^ 'D' STO*
  20.           \>> IFTE 2
  21.         STEP 1 B SIZE 1 -
  22.         FOR c B c 1 + GET B c GET 2 / DUP FP
  23.           \<< IP OVER SWAP ^ 'D' SWAP STO/ 'E' SWAP STO/
  24.           \>>
  25.           \<< ^ 'D' SWAP STO/
  26.           \>> IFTE 2
  27.         STEP D \->Q E \->Q STD DUP TYPE
  28.         \<< \v/ *
  29.         \>>
  30.         \<< "'\v/" SWAP \->STR + OBJ\-> DUP EVAL FP NOT
  31.           \<< EVAL
  32.           \>> IFT *
  33.         \>> IFTE *
  34.       \>>
  35.     \>>
  36.   QF
  37.     \<< \->NUM DUP SIGN SWAP SQ 5 FIX \->Q DUP TYPE
  38.       \<< OBJ\-> DROP2 PF FS SWAP PF FS
  39.       \>>
  40.       \<< { 1 1 } SWAP PF FS
  41.       \>> IFTE 1 1 \-> B A D E
  42.       \<< 1 A SIZE 1 -
  43.         FOR c A c 1 + GET A c GET 2 / DUP FP
  44.           \<< IP OVER SWAP ^ 'D' STO* 'E' STO*
  45.           \>>
  46.           \<< ^ 'D' STO*
  47.           \>> IFTE 2
  48.         STEP 1 B SIZE 1 -
  49.         FOR c B c 1 + GET B c GET 2 / DUP FP
  50.           \<< IP OVER SWAP ^ 'D' SWAP STO/ DUP 'E' STO* 'D' SWAP STO/
  51.           \>>
  52.           \<< ^ 'D' SWAP STO/
  53.           \>> IFTE 2
  54.         STEP D \->Q E \->Q STD DUP TYPE
  55.         \<< \v/ *
  56.         \>>
  57.         \<< "'\v/" SWAP \->STR + OBJ\-> DUP EVAL FP NOT
  58.           \<< EVAL
  59.           \>> IFT *
  60.         \>> IFTE *
  61.       \>>
  62.     \>>
  63.   FS
  64.     \<< 0 \-> l c
  65.       \<< { } l 1 GET 1 l SIZE
  66.         FOR p l p GET SAME
  67.           \<< 'c' INCR DROP
  68.           \>>
  69.           \<< c + l p 1 - GET + 1 'c' STO
  70.           \>> IFTE l p GET
  71.         NEXT c SWAP 1 \->LIST + +
  72.       \>>
  73.     \>>
  74.   PF
  75.     \<< { } OVER SIGN -1 ==
  76.       \<< -1 +
  77.       \>> IFT SWAP ABS 1 \->LIST
  78.       DO DUP DUP DUP SIZE SWAP OVER GET DUP 2 / IP 2 \-> n h c
  79.         \<<
  80.           WHILE c h \<= n c / FP AND
  81.           REPEAT 'c' INCR DROP
  82.           END n 1 c h \<=
  83.           \<< DROP c SWAP OVER / 2
  84.           \>> IFT \->LIST
  85.         \>> REPL
  86.       UNTIL SWAP OVER ==
  87.       END +
  88.     \>>
  89. END
  90.